home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / tools / cpx_acc / cpxbasic / beispiel / regress.bas < prev    next >
Encoding:
BASIC Source File  |  1994-09-22  |  8.8 KB  |  238 lines
  1. 10    REM lineare Regression
  2. 20    CLEAR:GOSUB 410:REM Initialisierung
  3. 30    WHILE:REM Hauptmenü
  4. 40      CLS:USING:USING$:PRINT cur_off$
  5. 50      PRINT '      ' rev_on$ ' lineare Regression ' rev_off$
  6. 60      PRINT '            V. 1.00'
  7. 70      PRINT '     ' CHR$($BD)' J.Starzynski 1990/93'
  8. 80      PRINT:PRINT:PRINT
  9. 90      PRINT '  ' rev_on$ 'R' rev_off$ 'egressionsart: ';art$(m)
  10. 100     PRINT '  ' rev_on$ 'E' rev_off$ 'ingabe der Werte: ';z;'Werte'
  11. 110     PRINT '  ' rev_on$ 'S' rev_off$ 'ichern der Werte'
  12. 120     PRINT '  ' rev_on$ 'L' rev_off$ 'esen der Werte'
  13. 130     PRINT '  ' rev_on$ 'W' rev_off$ 'ertebereich: ',anfw+1,'- ',endw
  14. 140     PRINT '  ' rev_on$ 'A' rev_off$ 'usgeben der Ergebnisse'
  15. 150     PRINT '  ' rev_on$ 'D' rev_off$ 'ateiausgabe der Ergebnisse'
  16. 160     PRINT '  ' rev_on$ 'K' rev_off$ 'orrektur'
  17. 170     PRINT '  ' rev_on$ 'U' rev_off$ 'nterprogramm, Zeile: ',rechen
  18. 180     PRINT '  ' rev_on$ 'P' rev_off$ 'lot'
  19. 190     PRINT '  ' rev_on$ 'Q' rev_off$ 'uit'
  20. 200     PRINT cur_on$
  21. 210     PRINT 'Ihre Wahl: ';:GOSUB transform
  22. 220     WHILE:answer$=INKEY$:WEND answer$<>''
  23. 230     PRINT answer$
  24. 240     IF answer$='r' OR answer$='R' THEN GOSUB 540
  25. 250     IF answer$='e' OR answer$='E' THEN GOSUB 610
  26. 260     IF answer$='s' OR answer$='S' THEN GOSUB 1100
  27. 270     IF answer$='l' OR answer$='L' THEN GOSUB 840
  28. 280     IF answer$='w' OR answer$='W' THEN GOSUB 2260
  29. 290     IF answer$='a' OR answer$='A' THEN GOSUB 1550:GOSUB 1790
  30. 300     IF answer$='d' OR answer$='D' THEN GOSUB 940
  31. 310     IF answer$='u' OR answer$='U' THEN GOSUB 1330
  32. 320     IF answer$='k' OR answer$='K' THEN GOSUB 1150
  33. 330     IF answer$='p' OR answer$='P' THEN GOSUB 2070
  34. 340     IF answer$<>'q' AND answer$<>'Q' THEN 380
  35. 350     PRINT:PRINT 'Wirklich Schluß? ' rev_on$ 'Y' rev_off$ '/N ';
  36. 360     WHILE:answer$=INKEY$:WEND answer$<>''
  37. 370     IF answer$<>'n' AND answer$<>'N' THEN CLS:END
  38. 380   WEND:REM Hauptmenü
  39. 390   REM
  40. 400   REM Initialisierungen
  41. 410   CLS:FCLOSE
  42. 420   listval=LABEL 1030:waitk=LABEL 580:transform=LABEL 1900
  43. 430   esc$=CHR$(27):cur_off$=esc$+'f':cur_on$=esc$+'e'
  44. 440   rev_off$=esc$+'q':rev_on$=esc$+'p'
  45. 450   maxanz=100:INPUT 'max. Wertezahl (100): ';maxanz_$
  46. 460   IF maxanz_$<>'' THEN maxanz=VAL(maxanz_$)
  47. 470   DIM xw(maxanz-1):DIM yw(maxanz-1)
  48. 480   DIM xwt(maxanz-1):DIM ywt(maxanz-1)
  49. 490   DIM art$(2):art$(0)='Y=a*X+b':art$(1)='Y=a*X mittl.'
  50. 500   art$(2)='Y=a*X beste'
  51. 510   RETURN
  52. 520   REM
  53. 530   REM Umschalten der Regressionsart
  54. 540   m=m+1:IF m>2 THEN m=0
  55. 550   RETURN
  56. 560   REM
  57. 570   REM waitk: warten auf Tastendruck
  58. 580   PRINT cur_off$:PRINT '  Bitte eine Taste drücken!';
  59. 590   WHILE:WEND INKEY$<>'':PRINT cur_on$:RETURN
  60. 600   REM
  61. 610   REM die Eingabe-Routine
  62. 620   CLS:PRINT:PRINT '  Werte-Eingabe':PRINT:PRINT '  Ende mit Q, Korrektur mit K':PRINT
  63. 630   USING 0,1:oldz=z
  64. 640   WHILE z<maxanz:REM Werteeingabe
  65. 650     PRINT 'X';z+1;
  66. 660     INPUT ': ';aa$:IF aa$='' THEN 650
  67. 670     l$=MID$(aa$,1,1)
  68. 680     IF l$='q' OR l$='Q' OR l$='e' OR l$='E' THEN 800
  69. 690     IF l$<>'k' AND l$<>'K' THEN 720
  70. 700     IF z>0 THEN z=z-1
  71. 710     GOTO 650
  72. 720     PRINT 'Y';z+1;
  73. 730     INPUT ': ';ba$:IF ba$='' THEN 720
  74. 740     l$=MID$(ba$,1,1)
  75. 750     IF l$='q' OR l$='Q' OR l$='e' OR l$='E' THEN 800
  76. 760     IF l$='k' OR l$='K' THEN 650
  77. 770     a=VAL aa$:b=VAL ba$:xw(z)=a:yw(z)=b
  78. 780     z=z+1
  79. 790   WEND:REM Werteeingabe
  80. 800   IF oldz=endw THEN endw=z
  81. 810   changed=1:RETURN
  82. 820   REM
  83. 830   REM Maschinelles Einlesen der Werte
  84. 840   file$=FSEL$ '*.TXT'
  85. 850   IF file$='' THEN RETURN
  86. 860   CLS:PRINT 'Lese Datei':PRINT file$:FOPEN file$
  87. 870   FOR z=0 TO maxanz-1
  88. 880     FINPUT a,b:xw(z)=a:yw(z)=b
  89. 890     IF ERRNO<>0 THEN 910
  90. 900   NEXT z
  91. 910   FCLOSE:anfw=0:endw=z:changed=1:RETURN
  92. 920   REM
  93. 930   REM die Dateiausgabe
  94. 940   file$=FSEL$ '*.TXT':IF file$='' THEN RETURN
  95. 950   PRINT 'Ausgabe der Ergebnisse in die Datei':PRINT file$
  96. 960   fileflag=1:FOPEN file$
  97. 970   FPRINT:FPRINT '    x           y'
  98. 980   anfang=anfw:outanz=endw-1:GOSUB listval
  99. 990   GOSUB 1550:GOSUB 1790
  100. 1000  fileflag=0:FCLOSE:RETURN
  101. 1010  REM
  102. 1020  REM die Ausgabe der Werte
  103. 1030  CLS:USING 6,12:FPRINT
  104. 1040  FOR i=anfang TO outanz
  105. 1050    IF i<z THEN FPRINT xw(i),yw(i)
  106. 1060  NEXT i
  107. 1070  RETURN
  108. 1080  REM
  109. 1090  REM sichern der Werte in Datei
  110. 1100  CLS:file$=FSEL$ '*.TXT':IF file$='' THEN RETURN
  111. 1110  PRINT 'Sichern in Datei':PRINT file$:FOPEN file$
  112. 1120  anfang=0:outanz=z-1:GOSUB listval:FCLOSE:RETURN
  113. 1130  REM
  114. 1140  REM korrektur der Werte
  115. 1150  CLS:USING$:changed=0
  116. 1160  FOR j=0 TO z-1
  117. 1170    USING:PRINT j+1,': ',:USING 6,10:PRINT xw(j),yw(j):USING
  118. 1180    IF(j+1)MOD 15<>0 AND j+1<>z THEN 1300
  119. 1190    PRINT cur_off$,rev_on$ 'Q' rev_off$ 'uit ' rev_on$ 'K' rev_off$ 'orrektur oder mehr'
  120. 1200    WHILE:wait$=INKEY$:WEND wait$<>''
  121. 1210    IF wait$='q' OR wait$='Q' THEN 1310
  122. 1220    IF wait$<>'k' AND wait$<>'K' THEN 1290
  123. 1230    WHILE
  124. 1240      PRINT cur_on$:INPUT 'Welchen Wert korrigieren: ';k
  125. 1250    WEND k<=z AND k>0
  126. 1260    k=k-1:INPUT 'x: ';a;'y: ';b:xw(k)=a:yw(k)=b
  127. 1270    changed=1
  128. 1280    j=j-16:IF j<-1 THEN j=-1
  129. 1290    CLS
  130. 1300  NEXT j
  131. 1310  PRINT cur_on$:RETURN
  132. 1320  REM
  133. 1330  CLS:PRINT:PRINT '  In welchem Unterprogramm soll'
  134. 1340  PRINT '  transformiert werden?'
  135. 1350  PRINT:PRINT '  jetzt Zeile: ',rechen:PRINT
  136. 1360  INPUT '  Zeile: ' rechen
  137. 1370  changed=1:RETURN
  138. 1380  REM
  139. 1390  REM Unterprogramm
  140. 1400  z=z-2:GOSUB 1430:z=z+2:RETURN
  141. 1410  REM
  142. 1420  REM Unterprogramm
  143. 1430  IF z<31 THEN c=z:GOTO 1470
  144. 1440  RESTORE 1450
  145. 1450  DATA 40,50,60,80,100,200,500,1000
  146. 1460  FOR c=30 TO 37:READ a:IF z>a THEN NEXT c
  147. 1470  RESTORE 1480
  148. 1480  DATA 12.706,4.303,3.182,2.776,2.571,2.447,2.365,2.306,2.262,2.228
  149. 1490  DATA 2.201,2.179,2.16,2.145,2.131,2.12,2.11,2.101,2.093,2.086
  150. 1500  DATA 2.08,2.074,2.069,2.064,2.06,2.056,2.048,2.045,2.042
  151. 1510  DATA 2.021,2.009,2,1.99,1.984,1.972,1.965,1.96
  152. 1520  FOR a=1 TO c:READ d:NEXT a:RETURN
  153. 1530  REM 
  154. 1540  REM der Rechen- und Ausgabeteil
  155. 1550  u=0:v=0:w=0:x=0:y=0:num=endw-anfw
  156. 1560  FOR i=anfw TO endw-1
  157. 1570    a=xwt(i):b=ywt(i)
  158. 1580    IF m=1 THEN a=b/a
  159. 1590    u=u+SQU b:v=v+b:w=w+a*b:x=x+SQU a:y=y+a
  160. 1600  NEXT i
  161. 1610  b=0
  162. 1620  ON m GOTO 1690,1720
  163. 1630  GOSUB 1400
  164. 1640  a=(num*w-y*v)/(num*x-SQU y):b=(v-a*y)/num
  165. 1650  c=x-SQU y/num:c=SQRT((u-SQU v/num-SQU a*c)/c/(num-2))*d:d=c*SQRT(x/num)
  166. 1660  f=0:IF d<>0 THEN f=ABS(d/b*100)
  167. 1670  GOTO 1750
  168. 1680  REM m=1
  169. 1690  GOSUB 1430:a=y/num:c=SQRT((x-SQU y/num)/(SQU num-num))*d
  170. 1700  GOTO 1750
  171. 1710  REM m=2
  172. 1720  GOSUB 1400:a=w/x
  173. 1730  c=y/x*SQRT(u-SQU w/x)/(num-2)*d
  174. 1740  REM
  175. 1750  e=0:IF c<>0 THEN e=ABS(c/a*100)
  176. 1760  RETURN
  177. 1770  REM
  178. 1780  REM Ausgabe der Regressionsergebnisse
  179. 1790  CLS:FPRINT:FPRINT '  Regressionsart: ',art$(m):FPRINT
  180. 1800  FPRINT '  a=    ';a
  181. 1810  IF m=0 THEN FPRINT '  b=    ';b
  182. 1820  FPRINT '  Sa=   ';c
  183. 1830  IF m=0 THEN FPRINT '  Sb=   ';d
  184. 1840  FPRINT '  Sa/a= ';e;'%'
  185. 1850  IF m=0 THEN FPRINT '  Sb/b= ';f;'%'
  186. 1860  IF m<>1 THEN FPRINT '  r=    ';(num*w-y*v)/SQRT((num*x-SQU y)*(num*u-SQU v))
  187. 1870  IF fileflag=0 THEN GOTO waitk ELSE RETURN
  188. 1880  REM
  189. 1890  REM transformiere, ermittle Maximum und Minimum in x und y
  190. 1900  IF changed=0 THEN RETURN
  191. 1910  maxx=anfw:minx=anfw:maxy=anfw:miny=anfw
  192. 1920  a=xw(anfw):b=yw(anfw)
  193. 1930  IF rechen<>0 THEN GOSUB rechen
  194. 1940  xwt(anfw)=a:ywt(anfw)=b
  195. 1950  maxxv=a:minxv=a:maxyv=b:minyv=b
  196. 1960  FOR i=anfw+1 TO endw-1
  197. 1970    a=xw(i):b=yw(i)
  198. 1980    IF rechen<>0 THEN GOSUB rechen
  199. 1990    xwt(i)=a:ywt(i)=b
  200. 2000    IF a>maxxv THEN maxx=i:maxxv=a
  201. 2010    IF b>maxyv THEN maxy=i:maxyv=b
  202. 2020    IF a<minxv THEN minx=i:minxv=a
  203. 2030    IF b<minyv THEN miny=i:minyv=b
  204. 2040  NEXT
  205. 2050  changed=0:RETURN
  206. 2060  REM
  207. 2070  REM Plotten der Werte
  208. 2080  CLS:USING$:USING:ausg=3:g1x=255-ausg:g1y=175-ausg:GOSUB 1550
  209. 2090  IF a<0 THEN GOTOXY 0,20
  210. 2100  PRINT cur_off$,'X: ',xw(minx),'- ',xw(maxx)
  211. 2110  PRINT 'Y: ',yw(miny),'- ',yw(maxy);
  212. 2120  diffx=maxxv-minxv:diffy=maxyv-minyv
  213. 2130  IF diffx=0 OR diffy=0 THEN GOTO waitk
  214. 2140  gax=(g1x-ausg)/diffx:gay=(g1y-ausg)/diffy
  215. 2150  gbx=(ausg*maxxv-g1x*minxv)/diffx
  216. 2160  gby=(ausg*maxyv-g1y*minyv)/diffy
  217. 2170  FOR i=anfw TO endw-1:REM Punkte plotten
  218. 2180    gx=gax*xwt(i)+gbx:gy=gay*ywt(i)+gby:CIRCLE gx,gy,2
  219. 2190  NEXT
  220. 2200  REM jetzt die Regressionsgerade ausgeben
  221. 2210  y1=-a*gbx/gax+b:y2=a*(255-gbx)/gax+b
  222. 2220  y1=gay*y1+gby:y2=gay*y2+gby
  223. 2230  LINE 0,y1,255,y2
  224. 2240  WHILE:WEND INKEY$<>'':PRINT cur_on$:RETURN
  225. 2250  REM
  226. 2260  IF z<=0 THEN GOTO waitk
  227. 2270  anfw=anfw+1:CLS:USING 0,0:USING$
  228. 2280  PRINT '  Welche Werte sollen':PRINT '  berücksichtigt werden?':PRINT
  229. 2290  WHILE
  230. 2300    PRINT 'von ( ',anfw;')';:INPUT ': ',aa$
  231. 2310    IF aa$<>'' THEN changed=1:anfw=VAL(aa$)
  232. 2320  WEND anfw>=1 AND anfw<=z
  233. 2330  WHILE
  234. 2340    PRINT 'bis ( ',endw;')';:INPUT ': ',aa$
  235. 2350    IF aa$<>'' THEN changed=1:endw=VAL(aa$)
  236. 2360  WEND endw>=anfw AND endw<=z
  237. 2370  anfw=anfw-1:RETURN
  238.